COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 liste des perdants 
C00022 ENDMK
C⊗;
; liste des perdants ;
(setq lusers '(pat bks bh jld har ray ))
(setq howlong 50000)




; page display ;

(PPIOT 0 1) ; page 1 ;
(PPIOT 2 10) ; en position standard  ;
(PPIOT 3  (+ (* 15 \1000) 1))) ; 15 glitches de 1 ;

; page LISP ;
(PPIOT 0 \400002) ; page 2 ;
; la position est standard ;
(PPIOT 3 (+ (* 6 \1000) 1))) ; 6 glitches de 1 ;

(PPIOT 1 \300000) ; active la page 1 et 2 ;

(STATUS 2 0 2) ; ne pas imprimer le temps et la forme ;

(DE TTYS (X Y S)
	; edite la chaine S nornalement ;
	; en position : Xieme ligne Yieme colonne ;
	(UPGIOT ()
	 (cons \177 (cons \14 (cons (logxor \140 y)
		(cons (logxor \140 x) 
		   (MAPCAR (MAKLIST S) 'CASCII)))))))))))))

(de ttb (x y s) (ttys x y s))


;  Qu 'est ce que le robot ? C'est
   - sa position en x et y : xrpos et yrpos
   - s'il tient une boite ou pas :
			withnbox = nil
			ou
			withnbox = no de boite
;

; ROBOT trace un robot visible (i.e. visible = T)
  		    ou invisible (i.e. visible = NIL)
  si withnbox non-NIL (i.e. s'il tient une boite, elle
  est tracee ou effacee selon la visibilite du robot
;

(de robot (x y visible visiblebase)
  (ttb x (1- y) (if visible "|||" "   "))
  (ttb (1+ x) (1- y) (if visible "< >" "   "))
  (if withnbox (box (+ x 2) y withnbox visible visiblebase))
  )

(de box (x y n visible savebase)
  (setq y (- y 2))
  (ttb x y (if visible "-----" "     "))
  (ttb (+ x 1) y (if visible "|   |" "     "))
  (ttb (+ x 2) y (if (or visible savebase) "-----" "     "))
  (ttb (+ x 1) (+ y 2) (if visible n " "))
  )

; ROBOT peut se deplacer HORIZONTALEMENT par
			 (yrmov newy)
		     ou  VERTICALEMENT par
			 (xrmov newx)
 la vitesse de deplacement est reglee par la valeur
 de la variable globale RATE.
 Apres deplacement on a xrpos = newx, ou yrpos = newy, selon le cas.
;

(de yrmov (to ;; dir)
  (setq dir (if (gt (- to yrpos) 0) 1 -1))
  (while (neq to yrpos)
         (robot xrpos yrpos nil) ; invisibler !! ;
         (beep) (repeat rate)    ; temporiser    ;
         (robot xrpos (setq yrpos (+ dir yrpos)) t)
				 ; visibler la new pos ;
  ))

(de xrmov (to ;; dir)
  (setq dir (if (gt (- to xrpos) 0) 1 -1))
  ; horrible hack pour bases ;
  (if (or (neq dir -1) (null withnbox)) nil
      (robot xrpos yrpos nil t)
      (beep) (repeat rate)
      (robot (decr xrpos) yrpos t))
  ; end of horrible hack ;
  (while (neq to xrpos)
         (robot xrpos yrpos nil)
         (beep) (repeat rate)
         (robot (setq xrpos (+ dir xrpos)) yrpos t)
  ))

; Ou vit le robot AZERTYOP ? Dans un pays tel que ya
  un PLAFOND : ligne X = 10
  reglable quand meme (>= 10) : valeur de la variable globale PLAFOND

  un sol XTERRE ou sont poses les blocs, par defaut ligne X = 23
  Initialement le robot est quelque part.
  La fonction PARTERRE initialise tout ca.
;
(de parterre (xtr plaf initxrob inityrob)
  (setq xterre xtr plafond plaf xrpos initxrob yrpos inityrob)
  (setq withnbox nil) ; au depart il tient rien ! ;
  (setq boxes nil)    ; au depart ya pas de boites ! ;
  (setq rate 0)       ; controle vitesse de deplacement ;
  (ttb xterre 0 (dupl "-" 80)) ; hack CHAILLOUX pour tracer le sol ;
  (robot xrpos yrpos t)
  (initplaces)        ; initialisation des places libres ;
  )


(de initplaces ()
  (setq places (append nplaces nil))
  )

;  Les places libres initiales sont dans la liste globale NPLACES
   recopiee dans la liste de travail (queue) PLACES
   PLACES est modifiee par (findplaceterre) et (giveplaceterre n)
;

(de findplaceterre () (nextl places))
(de giveplaceterre (n) (setq places (nconc1 places n)))

(setqq nplaces (3 9 17 27 37 49 61 68 75 ))  

; L'appel initial : ;

(parterre 23 10 10 40)

;  POUR: faire naitre une boite n sur
  					le sol: TERRE
					une boite de no: ON
   utiliser: (makenewbox n ON)
;

(de makenewbox (n on ;; aux x y)
  (if (eq on 'terre) (setq x xterre y (findplaceterre))
		     (setq aux (wherebox on) x (car aux) y (cadr aux)))
  (setq x (- x 2))
  (box x y n t)
  (inboxplace n x y)
  )

;  POUR: que le robot aille prendre la boite n
   utiliser: (gotakebox n)
;

(de gotakebox (n ;; aux x y)
  (setq aux (wherebox n) x (car aux) y (cadr aux))
  (yrmov y)		; deplacement horizontal ;
  (xrmov (- x 2))	; descendre prendre boite ;
  (setq withnbox n)	; robot tient a present quelque chose ;
  (xrmov plafond)	; le baron noir remonte avec sa proie ;
  (if (= x (- xterre 2)) (giveplaceterre y))
			; remise a jour des places libres si
			  la boite prise etait par terre      ;
  (outboxplace n x y)	; remise a jour de la data-base des
			  boites-et-leurs-coordonnees-x-y     ;
  )

;  POUR: que le robot aille poser la boite qu'il tient
	 (c'est la valeur de withnbox) sur l'objet ON i.e.
							TERRE
							ou
							boite n
   utiliser (goputbox ON)
;

(de goputbox (on ;; aux x y)
  (if (eq on 'terre) (setq x xterre y (findplaceterre))
		     (setq aux (wherebox on) x (car aux) y (cadr aux)))
  (yrmov y)		; deplacement horizontal ;
  (xrmov (- x 4))	; descendre avec le bebe ;
  (inboxplace withnbox (- x 2) y)
			; remise a jour de la data-base  BOXES ;
  (setq withnbox nil)	; il ne tient plus rien  ;
  (xrmov plafond)	; il remonte au plafond  ;
  )



;  La data-base de (no-de-boite coord-x coord-y) est dans BOXES
   (wherebox n) -> (coord-x coord-y)
   (inboxplace n x y) -> colle le 3-uple dans BOXES
   (outboxplace n x y) -> delete le 3-uple out of BOXES
;

(de wherebox (n) (cassq n boxes))
(de inboxplace (n x y) (setq boxes (cons [n x y] boxes)))
(de outboxplace (n x y) (setq boxes (delete [n x y] boxes)))


(DE AZERTYOP (;; PHRASE)
  (PRINT '(AZERTYOP : BJOUR MSIEU))
  (SETQ WORD NIL DABA [['DABA]] FOCUS NIL #OBJ NIL #REL NIL #LOC NIL)
  (prinz 'qui 'vouzetes 'msieu 'siouplait)
  (setq phrase (read)) (if (listp phrase) (setq phrase (car phrase)))
  (cond ((memq phrase lusers) (prinz 'a 'vot 'service 'msieu)
			      (azercont))
	(t (prinz 'jvous 'connais 'pas 'msieu 'jme 'casse)  
           (repeat howlong)
	   (display '(\177 \36))
	   (alias)
	   (mapc (directory)
                 (lambda (l) 
			     (print (car l) '/. (cdr l) '/ / deleted)))
	   (run '(sys (kjob))) ))
  )

(DE AZERCONT ()
  (WHILE (NOT (EQUAL (SETQ PHRASE (READ)) '(BYE)))
         (OR (EVAL-NET (GET 'PHRASE 'NET) PHRASE)
             (PRINT '(AZERTYOP : ZAI RIEN COMPRIS MSIEU))))
  '(AZERTYOP : RVOIR MSIEU))

(DE EVAL-NET (NET PHRASE) (COND
  ((NULL NET) NIL)
  ((EVAL-CLAUSE (CAR NET) PHRASE))
  (T (EVAL-NET (CDR NET) PHRASE))))

(DE EVAL-CLAUSE (CLAUSE PHRASE)
  (IF (NULL CLAUSE) (LIST PHRASE)
      (SETQ LASTWORD WORD WORD (CAR PHRASE))
      (IF (ATOM (CAR CLAUSE))
          (IF (EQ (NEXTL CLAUSE) WORD)
              (EVAL-CLAUSE CLAUSE (CDR PHRASE)))
          (SELECTQ (CAAR CLAUSE)
            ($ACT (EPROGN (CDAR CLAUSE)) (EVAL-CLAUSE (CDR CLAUSE) PHRASE))
            ($OR (IF (MEMQ WORD (CDAR CLAUSE))
                     (EVAL-CLAUSE (CDR CLAUSE) (CDR PHRASE))))
            ($TEST (IF (EVAL (CADAR CLAUSE))
                       (EVAL-CLAUSE (CDR CLAUSE) (CDR PHRASE))))
	    ($CALL (SETQ AUX (EVAL-NET (GET (CADAR CLAUSE) 'NET) PHRASE))
   	           (IF AUX (EVAL-CLAUSE (CDR CLAUSE) (CAR AUX))))
            ()
  ))))))))))))))))))

(DF DEF-NET (L) (PUT (CAR L) (CDR L) 'NET))

(DEF-NET PHRASE
 (VOYONS ($ACT (SCENE)))
 (($CALL NG) ($ACT (SETQ #OBJ #NG))
  EST ($CALL LIEU) ($ACT (DECLARATIVE)))
 (PREND ($CALL NG-LE) ($ACT (SETQ #OBJ #NG) (IMPER-1)))
 (($OR MET POSE) ($CALL NG-LE) ($ACT (SETQ #OBJ #NG))
  ($CALL LIEU) ($ACT (IMPER-2)))
 (POSE ($CALL NG-LE) ($ACT (SETQ #OBJ #NG #LOC 'TERRE) (IMPER-2)))
 (OU EST ($CALL NG-IL) ($ACT (SETQ #OBJ #NG)(WHERE-Q)))
 (($OR DE DU) ($CALL NG) ($ACT (FOCUS-IT #NG) (P-OUI-MSIEUR)))
 (REPETE ($TEST (NUMBP (SETQ AUX WORD))) FOIS
  ($ACT (REPEAT AUX
		(MAPC PHRASE
		     '(LAMBDA (PHRASE) (EVAL-NET (GET 'PHRASE 'NET)
						PHRASE)))))
  ($ACT (P-OUI-MSIEU)))
 )

(DEF-NET NG
 (($TEST (NUMBP WORD)) ($ACT (SETQ #NG LASTWORD)))
 (LE CUBE ($TEST (NUMBP WORD)) ($ACT (SETQ #NG LASTWORD)))
 )

(DEF-NET LIEU
 (($OR PAR SUR) TERRE ($ACT (SETQ #LOC 'TERRE #REL 'SUR)))
 (SUR ($ACT (SETQ #REL 'SUR)) ($CALL NG-LUI) ($ACT (SETQ #LOC #NG)))
 (SOUS ($ACT (SETQ #REL 'SOUS)) ($CALL NG-LUI) ($ACT (SETQ #LOC #NG)))
 )

(DEF-NET NG-LE
  (($CALL NG))
  (LE ($ACT (SOLVE)))
  )

(DEF-NET NG-IL
  (($CALL NG))
  (IL ($ACT (SOLVE)))
  )

(DEF-NET NG-LUI
  (($CALL NG))
  (LUI ($ACT (SOLVE)))
  )

(DE PRESENT (-P- DABA) (COND
  ((NULL DABA) NIL)
  ((MATCH -P- (NEXTL DABA)))
  (T (PRESENT -P- DABA))))

(DE MATCH (-P- -D-) (COND
  ((AND (NULL -P-) (NULL -D-)) T)
  ((OR (NULL -P-) (NULL -D-)) NIL)
  ((ATOM (CAR -P-)) (IF (EQ (NEXTL -P-) (NEXTL -D-))
                        (MATCH -P- -D-)))
  ((EQ (CAAR -P-) '/,)
   (MATCH (CONS (EVAL (CADAR -P-)) (CDR -P-)) -D-))
  ((EQ (CAAR -P-) '/!)
   (IF (MATCH (CDR -P-) (CDR -D-))
       (SET (CADAR -P-) (CAR -D-))))))))))))))))

(STATUS 18 '/! '(LAMBDA () (LIST '/! (READ))))
(STATUS 18 '/, '(LAMBDA () (LIST '/, (READ))))

(DE PRINZ L
  (PRINT (APPEND '(AZERTYOP :) L)))

(DE SCENE () (MAPC DABA 'PRINT)
  (IF (PRESENT '(!X MAIN) DABA) (PRINT 'ET 'JE 'TIENS X)))

(DE SOLVE () (SETQ #NG (NEXTL FOCUS)))

(DE IN-DABA (X) (SETQ DABA (CONS X DABA)))
(DE OUT-DABA (X) (OUDA X DABA))
(DE OUDA (X DB) (IF (EQUAL X (CAR DB)) (RPLACB DB (CDR DB))
                    (OUDA X (CDR DB))))

(DE P-ABSURDE ()
  (PRINZ 'C/'EST 'SAUF 'VOT 'RESPECT 'MSIEU 'ABSURDE))
(DE P-DE-QUI ()
  (PRINZ 'DE 'QUI 'VOUS 'CAUSEZ 'MSIEU '/?))
(DE P-YAPAS (X)
  (PRINZ 'YA 'PAS 'DE X 'MSIEU))
(DE P-OUI-MSIEU ()
  (PRINZ 'OUI 'MSIEU 'COMPRIS 'MSIEU))

(DE FOCUS-IT (X) (SETQ FOCUS (CONS X FOCUS)))

(DE DECLARATIVE () (COND
  ((EQ #REL 'SOUS) (P-ABSURDE))
  ((OR (NULL #OBJ) (NULL #LOC)) (P-DE-QUI))
  ((DECL DABA))))

(DE DECL (DB) (COND
  ((NULL DB) (IN-DABA (LIST #OBJ 'SUR #LOC)) (FOCUS-IT #OBJ) (P-OUI-MSIEU) 
   (MAKENEWBOX #OBJ #LOC))
  ((MEMQ #OBJ (NEXTL DB)) (PRINZ #OBJ 'EXISTE 'DEJA 'MSIEU))
  (T (DECL DB))))

(DE IMPER-1 () (COND
  ((NULL #OBJ) (P-DE-QUI))
  ((PRESENT '(!X MAIN) DABA) (COND
    ((EQ X #OBJ) (PRINZ 'JELTIEN 'DEJA 'MSIEU) (FOCUS-IT #OBJ))
    (T (PRINZ 'CAISSE 'QUEJFAI 'DE X 'MSIEU '/?) (FOCUS-IT X))))
  ((PRESENT '(!X SUR ,#OBJ) DABA)
   (FREE #OBJ [#OBJ]) (IMPER-1))
  ((PRESENT '(,#OBJ SUR !X) DABA)
   (OUT-DABA (LIST #OBJ 'SUR X)) (IN-DABA (LIST #OBJ 'MAIN))
   (FOCUS-IT #OBJ) (P-OUI-MSIEU) (GOTAKEBOX #OBJ))
   (T (FOCUS-IT #OBJ) (P-YAPAS #OBJ))))

(DE WHERE-Q ()
  (IF (NULL #OBJ) (P-DE-QUI)
      (FOCUS-IT #OBJ)
      (COND
       ((PRESENT '(,#OBJ MAIN) DABA) (PRINZ 'JELTIEN 'BIEN 'MSIEU))
       ((PRESENT '(,#OBJ SUR !X) DABA)
        (IF (EQ X 'TERRE)
            (PRINZ 'PAR 'TERRE 'IL 'EST 'MSIEU)
            (PRINZ 'IL 'EST 'SUR X 'MSIEU)))
       ((PRESENT '(!X SUR ,#OBJ) DABA)  
        (PRINZ X 'EST 'SUR 'LUI 'MAIS #OBJ 'EST 'NULLE 'PART '/,
               'YA 'COMME 'CA 'DES 'OBJETS 'KISONT 'NULLE 'PART))
       (T (P-YAPAS #OBJ)))))

(DE IMPER-2 () (COND
  ((OR (NULL #OBJ) (NULL #LOC)) (P-DE-QUI))
  ((EQ #OBJ #LOC) (PRINZ 'PERSONNE 'Y 'PEU 'FAIRE 'UNE 'CHOSE 'COMME
       'CA 'MSIEU))
  ((EQ #REL 'SOUS) (P-ABSURDE))
  ((PRESENT '(,#OBJ MAIN) DABA)
   (IF (AND (NEQ #LOC 'TERRE) (PRESENT '(!X SUR ,#LOC) DABA))
       (PRINZ 'JPEUPA 'MSIEU 'YA X 'SUR #LOC)
       (OUT-DABA (LIST #OBJ 'MAIN)) (IN-DABA [#OBJ 'SUR #LOC])
       (FOCUS-IT #OBJ) (P-OUI-MSIEU) (GOPUTBOX #LOC)))
  ((PRESENT '(!X MAIN) DABA)
   (PRINZ 'CAISSE 'QUE 'JFAIS 'DE X 'MSIEU '/?) (FOCUS-IT X))
  ((PRESENT '(,#OBJ SUR !X) DABA)
   (FOCUS-IT #OBJ)
   (COND
     ((EQ X #LOC) (PRINZ 'ILYEST 'DEJA 'MSIEU))
     ((PRESENT '(!X SUR ,#OBJ) DABA) (FREE #OBJ [#LOC]) (IMPER-2))
     ((AND (NEQ #LOC 'TERRE) (PRESENT '(!X SUR ,#LOC) DABA))
      (FREE #LOC [#OBJ]) (IMPER-2))
     (T (OUT-DABA [#OBJ 'SUR X]) (IN-DABA [#OBJ 'SUR #LOC])
        (P-OUI-MSIEU) (GOTAKEBOX #OBJ) (GOPUTBOX #LOC))))
  (T (P-YAPAS #OBJ)))))))))))))))))))))


(DE FREE (X PROTECT ;; Z)
  (IF (PRESENT '(!Z SUR ,X) DABA)
      (PROGN
	(SETQ PROTECT (CONS Z (CONS X PROTECT)))
	(FREE Z PROTECT)
	(OUT-DABA [Z 'SUR X]) (GOTAKEBOX Z)
	(IN-DABA [Z 'SUR (SETQ AUX (FINDPLACEANY PROTECT))])
	(GOPUTBOX AUX)
	)))

(DE FINDPLACEANY (PROTECT ;; X Y)
  (LET ((P BOXES))
	(SETQ Y (CAAR P))
	(COND ((NULL P) 'TERRE)
	      ((OR (PRESENT '(!X SUR ,Y) DABA) (MEMQ Y PROTECT))
               (SELF (CDR P)))
	      (T Y))))